perm filename LINEW.F4[PIC,LCS] blob
sn#632691 filedate 1982-01-09 generic text, type T, neo UTF8
SUBROUTINE LINES(I)
COMMON/FU/FUJ(512),JJX,RDIV,ADML/MEDGE/MC,MD,RMC,MMD
COMMON/DRW/JDRW(2000)
EQUIVALENCE(KNT,JDRW(1))
COMMON/PLT/JX,JY,JPL,PLT,REV,RINV,ROT,RLR,RUD,CONST,E
1 ,JREV,JINV,KA,KB,KC,KD,RTO,JA,JB,JAR,JBR,A,IA,IB,IC,ID
DATA IFLIP/-1/,RDIV/.5/,FUJ(1)/99./
CALL SWITCH
C REVERSE OR INVERT (IN 'SWITCH') HAPPEN BEFORE DISTORTION OR ROTATE.
IF(FUJ(1).EQ.99)GO TO 31
RX=JA*RMC+1
IF(RX.GT.512.)RX=512.
IF(ADML.GE.0)GO TO 32
JB=JB+MMD*FUJ(IFIX(RX))
C 'CENTR' IS MULT FOR ADDING! (CENTR 102 = MULT THE FUNC BY 2 AND ADD)
GO TO 31
32 NY=JB-MMD
JB=MMD+NY*FUJ(IFIX(RX))
31 IF(ROT.LE.1)GO TO 9
RX=JA
RY=JB
AX=ATAN2(RY,RX)*57.29578
HYP=SQRT(RX**2+RY**2)
RT=ROT+AX
JA=HYP*COSD(RT)
JB=HYP*SIND(RT)
GO TO 10
9 IF(ROT.GT.0)CALL EXCH(JA,JB)
10 JA=JA+JX
JB=JB+JY
C IF ROT.GE.0 ROTATE 90 DEG. TO LEFT
M=JA
N=JB
IF(PLT)GO TO 1
6 M=M-JAR
N=N-JBR
CC2 TYPE 20,M,N,JX,JY
20 FORMAT(4I6)
IF(I.EQ.3)GO TO 3
CALL RVECT(M,N)
5 JAR=JA
JBR=JB
RETURN
3 CALL RIVECT(M,N)
GO TO 5
CC1 TYPE 20,M,N,JX,JY
1 IF(PLT.EQ.-2)GO TO 4
CALL PLOT(M,N,I)
RETURN
4 IFLIP=-IFLIP
IF(I.EQ.3)GO TO 7
IF(KNT.GE.200.OR.IFLIP)RETURN
GO TO 70
7 IF(JDRW(KNT).GT.100000000)GO TO 71
70 KNT=KNT+1
71 M=M/8
N=N/8
IF(M.NE.KM)GO TO 56
IF(IABS(N-KN).GT.1)GO TO 55
IF(N.EQ.KN)GO TO 59
57 IF(JDRW(KNT-1).LT.100000000)KNT=KNT-1
GO TO 58
56 IF(N.NE.KN)GO TO 55
IF(IABS(M-KM).LE.1)GO TO 57
GO TO 55
59 IF(JDRW(KNT-1).LT.100000000)KNT=KNT-1
RETURN
55 IF(I.NE.3)GO TO 11
KM=10000
GO TO 8
11 IF(M-KM.NE.LM.OR.N-KN.NE.LN)GO TO 8
IF(JDRW(KNT-1).LT.100000000)KNT=KNT-1
8 LN=N-KN
LM=M-KM
KM=M
KN=N
58 M=(M-50)*10000
N=N-50
IF(M)M=10000000-M
IF(N)N=1000-N
IF(I.EQ.3)M=M+100000000
JDRW(KNT)=M+N
IF(JDRW(KNT).EQ.0)KNT=KNT-1
END
SUBROUTINE EXCH(J,K)
I=J
J=K
K=I
END
SUBROUTINE JZERO
COMMON/PLT/JX,JY,JPL,PLT,REV,RINV,ROT,RLR,RUD,CONST,E
1 ,JREV,JINV,KA,KB,KC,KD,RTO,JA,JB,JAR,JBR,A,IA,IB,IC,ID
JAR=0
JBR=0
END
SUBROUTINE DSTORT(JPL)
COMMON/MEDGE/MC,MD,RMC,MMD/FU/FUJ(512),JJX,RDIV,ADML
MMD=(MD/JPL)*RDIV
IF(ADML)MMD=RDIV*(MD/JPL)
C 'CENTR' IS MULT FOR ADDING! (CENTR 102 = MULT THE FUNC BY 2 AND ADD)
RMC=MC
RMC=511./(RMC/JPL)
END
SUBROUTINE INVIS(MA,MB,MC,MD,N)
DIMENSION LL(100)
COMMON/PLT/JX,JY,JPL,PLT,REV,RINV,ROT,RLR,RUD,CONST,E
1 ,JREV,JINV,KA,KB,KC,KD,RTO,JA,JB,JAR,JBR,A,IA,IB,IC,ID
CALL JZERO
NA=MA/3
NB=MB/3
NC=MC/3
ND=MD/3
IF(N.EQ.0)N=-1
IF(N)CALL DPYSET(2,LL,100)
N=1
CALL JZERO
CALL DPYBRT(2)
1 CALL AIVECT(-380,-200)
JA=NA
JB=NC
CALL LINES(3)
JB=NC
JA=NB
CALL LINES(2)
JB=ND
JA=NB
CALL LINES(2)
JA=NA
JB=ND
CALL LINES(2)
JA=NA
JB=NC
CALL LINES(2)
CALL JZERO
6683 CALL DPYOUT(2)
END
SUBROUTINE SWITCH
COMMON/PLT/JX,JY,JPL,PLT,REV,RINV,ROT,RLR,RUD,CONST,E
1 ,JREV,JINV,KA,KB,KC,KD,RTO,JA,JB,JAR,JBR,A,IA,IB,IC,ID
IF(REV.NE.0)JA=JREV-JA
IF(RINV.NE.0)JB=JINV-JB
END
SUBROUTINE DPFUN(JFU)
COMMON/FU/FUJ(512),JJX,RDIV,ADML/DRW/LIST(2000)
13 IF(JFU.NE.' ')GO TO 19
TYPE 14
14 FORMAT(' FUNC FILE NAME? ',$)
15 FORMAT(8F)
83 FORMAT(A5)
ACCEPT 83,JFU
IF(JFU.NE.' ')GO TO 19
FUJ(1)=99.
C A BLANK DELETES FUNC ACTION.
RETURN
19 REWIND 1
CALL IFILE(1,JFU)
DO 17 K=1,3
17 READ(1,18)A,B,B
18 FORMAT(3A5)
16 READ(1,15)A,B
IF(B.NE.520.0)GO TO 16
READ(1,15)FUJ
CALL DPYSET(3,LIST,500)
CALL ALINE(306,300,476,300)
CALL ALINE(306,215,306,385)
CC CALL AIVECT(0,0)
KY=FUJ(1)*85.0+300.
CALL AIVECT(306,KY)
DO 32 K=2,512,3
KY2=FUJ(K)*85.0+300.
CALL RVECT(1,KY2-KY)
32 KY=KY2
CALL DPYOUT(3)
END
SUBROUTINE DD
COMMON/DRW/JDRW(2000)
3 REWIND 21
6 K=JDRW(1)+1
IF(K.LE.201)GO TO 5
JDRW(1)=200
K=201
5 WRITE(21,120)K
120 FORMAT(' 9999 1 ',I4,' 0 0 0 0 0 0 0 0')
J=7
L=8
DO 12 K=1,JDRW(1),8
IF(K+J.LT.JDRW(1))GO TO 12
J=JDRW(1)-K
L=J+1
12 WRITE(21,11)L,(JDRW(N),N=K,K+J)
CALL EXIT
11 FORMAT(' 9999',I3,8I10)
END